unit CtrlTools;

interface

uses
  Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus, StdCtrls,
  Dialogs, Buttons, Messages, ExtCtrls, Grids, DBGrids, DB, Contnrs, ShadowWnd;

procedure StringGridToStrings( Grid: TStringGrid; s: TStrings; OnlySelection: boolean= false );
function  GetControlImage( WinControl: TWinControl ): TBitmap;
procedure CopyDBGridToClipboard( Grid: TCustomGrid );
procedure CopyStringGridToClipboard( Grid: TStringGrid; OnlySelection: boolean= false );
procedure InvalidateGridCell( Grid: TCustomGrid; ACol, ARow: integer );
procedure SetListBoxScrollWidth(LB:TCustomListBox);
procedure SetComboBoxDropWidth(CB:TCustomComboBox);
procedure SetChildControlsEnabled( c: TWinControl; enbld: boolean );

{Flash de Controles/Formularios}
type
  TFlashStyle = (fsCaption, fsBackground, fsFont, fsVisible);

procedure FlashControl( Control: TControl; Style: TFlashStyle; Color: TColor; time: word );
procedure FlashForm( Form: TForm; time: word );
procedure FlashStop( Control: TControl );
procedure FlashTick; {Invocar desde un timer cada ~1 seg}

{Sonidos}
var
  SoundEnabled : boolean = true;

procedure PlaySound( const nomarch: string; interrumpir: boolean );

{ShowHintHandlers}
procedure InstallShowHintHandler( Control: TControl; Handler: TShowHintEvent );
procedure RemoveShowHintHandler( Control: TControl );

{Menues}
procedure ExecuteDefaultMenuItem( Menu: TMenu );
procedure CopyMenuItems( DestItem, SourceItem: TMenuItem );
procedure AssignMenu( DestMenu, SourceMenu: TMenu );
procedure EnableMenuItems( MenuItem: TMenuItem; Enabled: boolean; From: integer= 0; SubMenus: boolean= false );

procedure RestoreForm( Form: TForm );
function FindForm( c: TComponentClass ): TForm; overload;
function FindForm( const FormName: string ): TForm; overload;

procedure NormalizeTopMosts;
procedure RestoreTopMosts;

function ComboBoxToStr( cb: TCustomComboBox; const default: string= '' ): string;
procedure StrToComboBox( cb: TCustomComboBox; const val: string; default: integer= -1 );
function ComboBoxToObject( cb: TCustomComboBox; const default: pointer= nil ): pointer;
procedure ObjectToComboBox( cb: TCustomComboBox; obj: pointer; default: integer= -1 );
function ComboBoxToInteger( cb: TCustomComboBox; const default: integer= 0 ): integer;
procedure IntegerToComboBox( cb: TCustomComboBox; val: integer; default: integer= -1 );

procedure SetLayeredAttribs( Handle: HWND; FAlphaBlend, FTransparentColor: boolean; FAlphaBlendValue: integer; FTransparentColorValue: TColor );

procedure GetWindowImage(Win: THandle; bm : TBitMap);

type
  TShadowForm = class(TForm)
  private
    FBShadow: TShadowWindow;
    FRShadow: TShadowWindow;
    FShadow: boolean;
    FShadowVisible : boolean;
    procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    procedure DisplayShadow;
    procedure HideShadow;
    procedure SetShadow(const Value: boolean);
  public
    property Shadow: boolean read FShadow write SetShadow;
  end;

implementation

uses
  Clipbrd, DBTools, wwDBGrid, MPlayer, MMSystem;

procedure ScreenShot(x : integer; y : integer; Width : integer; Height : integer; bm : TBitMap);
var
  dc: HDC; lpPal : PLOGPALETTE;
begin
{test width and height}
  if ((Width = 0) OR (Height = 0)) then exit;
  bm.Width := Width;
  bm.Height := Height;
{get the screen dc}
  dc := GetDc(0);
  if (dc = 0) then exit;
{do we have a palette device?}
  if (GetDeviceCaps(dc, RASTERCAPS) AND RC_PALETTE = RC_PALETTE) then
  begin
    {allocate memory for a logical palette}
    GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    {zero it out to be neat}
    FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    {fill in the palette version}
    lpPal^.palVersion := $300;
    {grab the system palette entries}
    lpPal^.palNumEntries :=GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);
    if (lpPal^.PalNumEntries <> 0) then
    begin
      {create the palette}
      bm.Palette := CreatePalette(lpPal^);
    end;
    FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
  end;
  {copy from the screen to the bitmap}
  BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,x,y,SRCCOPY);
  {release the screen dc}
  ReleaseDc(0, dc);
end; (* ScreenShot *)

procedure GetWindowImage(Win: THandle; bm : TBitMap);
var
  dc: HDC; lpPal : PLOGPALETTE;
  Width, Height : integer;
  r : TRect;
begin
{test width and height}
  RedrawWindow(Win,nil,0,RDW_INVALIDATE+RDW_FRAME+RDW_UPDATENOW+RDW_ALLCHILDREN);
  GetWindowRect(Win,r);
  Width := r.Right-r.Left;
  Height := r.Bottom-r.Top;
  if ((Width = 0) OR (Height = 0)) then exit;
  bm.Width := Width;
  bm.Height := Height;
{get the screen dc}
  dc := GetWindowDc(Win);
  if (dc = 0) then exit;
{do we have a palette device?}
  if (GetDeviceCaps(dc, RASTERCAPS) AND RC_PALETTE = RC_PALETTE) then
  begin
    {allocate memory for a logical palette}
    GetMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
    {zero it out to be neat}
    FillChar(lpPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
    {fill in the palette version}
    lpPal^.palVersion := $300;
    {grab the system palette entries}
    lpPal^.palNumEntries :=GetSystemPaletteEntries(dc,0,256,lpPal^.palPalEntry);
    if (lpPal^.PalNumEntries <> 0) then
    begin
      {create the palette}
      bm.Palette := CreatePalette(lpPal^);
    end;
    FreeMem(lpPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
  end;
  {copy from the screen to the bitmap}
  BitBlt(bm.Canvas.Handle,0,0,Width,Height,Dc,0,0,SRCCOPY);
  {release the screen dc}
  ReleaseDc(0, dc);
end; (* ScreenShot *)

procedure StringGridToStrings( Grid: TStringGrid; s: TStrings; OnlySelection: boolean= false );
var
  f,c : integer;
  x   : string;
  r   : TGridRect;
begin
  with Grid do
  begin
    if OnlySelection then r := Selection
    else
      with r do
      begin
        Left   := 0;
        Top    := 0;
        Right  := ColCount-1;
        Bottom := RowCount-1;
      end;
    for f := r.Top to r.Bottom do
    begin
      x := '';
      for c := r.Left to r.Right do
        if c=r.Left then x := Cells[c,f]
                    else x := x+#9+Cells[c,f];
      s.Add(x);
    end;
  end;
end;

function GetControlImage( WinControl: TWinControl ): TBitmap;
var
  ScreenDC, PrintDC: HDC;
  OldBits, PrintBits: HBITMAP;
  PaintLParam: Longint;
  SelfHandle : THandle;

  procedure PrintHandle(Handle: HWND);
  var
    R: TRect;
    Child: HWND;
    SavedIndex: Integer;
  begin
    if IsWindowVisible(Handle) then
    begin
      SavedIndex := SaveDC(PrintDC);
      Windows.GetClientRect(Handle, R);
      MapWindowPoints(Handle, SelfHandle, R, 2);
      with R do
      begin
        SetWindowOrgEx(PrintDC, -Left, -Top, nil);
        IntersectClipRect(PrintDC, 0, 0, Right - Left, Bottom - Top);
      end;
      SendMessage(Handle, WM_ERASEBKGND, PrintDC, 0);
      SendMessage(Handle, WM_PAINT, PrintDC, PaintLParam);
      Child := GetWindow(Handle, GW_CHILD);
      if Child <> 0 then
      begin
        Child := GetWindow(Child, GW_HWNDLAST);
        while Child <> 0 do
        begin
          PrintHandle(Child);
          Child := GetWindow(Child, GW_HWNDPREV);
        end;
      end;
      RestoreDC(PrintDC, SavedIndex);
    end;
  end;

begin
  Result := nil;
  ScreenDC := GetDC(0);
  PaintLParam := 0;
  with WinControl do
    try
      SelfHandle := Handle;
      PrintDC := CreateCompatibleDC(ScreenDC);
      { Work around an apparent bug in Windows NT }
      {if GetWinFlags and $4000 <> 0 then PaintLParam := PrintDC or $DEFE0000;}
      { !!!!!!!!! OJO CON LA LINEA DE ARRIBA !!!!!!!!!!!!!!!!!!!!!! }
      try
        PrintBits := CreateCompatibleBitmap(ScreenDC, ClientWidth, ClientHeight);
        try
          OldBits := SelectObject(PrintDC, PrintBits);
          try
            { Clear the contents of the bitmap }
            FillRect(PrintDC, ClientRect, Brush.Handle);

            { Paint form into a bitmap }
            PrintHandle(Handle);
          finally
            SelectObject(PrintDC, OldBits);
          end;
          Result := TBitmap.Create;
          Result.Handle := PrintBits;
          PrintBits := 0;
        except
          Result.Free;
          if PrintBits <> 0 then DeleteObject(PrintBits);
          raise;
        end;
      finally
        DeleteDC(PrintDC);
      end;
    finally
      ReleaseDC(0, ScreenDC);
    end;
end;

procedure CopyDBGridToClipboard( Grid: TCustomGrid );
var
  d : TDataset;
begin
  Clipboard.Open;
  if      Grid is TDBGrid   then d := (Grid as TDBGrid).Datasource.Dataset
  else if Grid is TwwDBGrid then d := (Grid as TwwDBGrid).Datasource.Dataset
  else d := nil;
  if d<>nil then CopyTableToClipboard(d);
  Clipboard.Assign(GetControlImage(Grid));
  Clipboard.Close;
end;

procedure CopyStringGridToClipboard( Grid: TStringGrid; OnlySelection: boolean= false );
var
  s : TStringList;
  t : pchar;
begin
  s := TStringList.Create;
  StringGridToStrings(Grid,s,OnlySelection);
  t := s.GetText;
  Clipboard.Open;
  Clipboard.SetTextBuf(t);
  Clipboard.Assign(GetControlImage(Grid));
  Clipboard.Close;
  s.Free;
  StrDispose(t);
end;

type
  TMiGrid = class(TCustomGrid)
  public
    procedure PublicInvalidateCell( ACol, ARow: integer );
  end;

procedure TMiGrid.PublicInvalidateCell( ACol, ARow: integer );
begin
  InvalidateCell(ACol,ARow);
end;

procedure InvalidateGridCell( Grid: TCustomGrid; ACol, ARow: integer );
begin
  TMiGrid(Grid).PublicInvalidateCell(ACol,ARow);
end;

(************************************************************************************************)

const
  FlashList : TObjectList = nil;

var
  FlashingState : boolean;

type
  TMiControl = class(TControl);
  TFlashData = class(TComponent)
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    Style : TFlashStyle;
    FormHandle  : word;
    Counter : word;
    OrigColor : TColor;
    OrigVisible : boolean;
    Color : TColor;
    Control : TControl;
    Flashing : boolean;
    ControlDestroyed : boolean;
  end;

procedure TFlashData.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  if AComponent=Control then
    ControlDestroyed := true;
end;

procedure FlashTickControl( d: TFlashData );
begin
  if d.ControlDestroyed then
  begin
    d.Counter := 0;
    exit;
  end;
  if d.Counter>0 then dec(d.Counter);
  case d.Style of
    fsCaption:
      if IsWindow(d.FormHandle) then FlashWindow(d.FormHandle,(d.Counter>0) or TForm(d.Control).Active)
                                else d.Counter := 0;
    fsBackground:
      try
        d.Flashing := FlashingState;
        if d.Counter=0 then d.Flashing := false;
        if d.Flashing then TMiControl(d.Control).Color := d.Color
                      else TMiControl(d.Control).Color := d.OrigColor;
      except
        d.Counter := 0;
      end;
    fsFont:
      try
        d.Flashing := FlashingState;
        if d.Counter=0 then d.Flashing := false;
        if d.Flashing then TMiControl(d.Control).Font.Color := d.Color
                      else TMiControl(d.Control).Font.Color := d.OrigColor;
      except
        d.Counter := 0;
      end;
    fsVisible:
      try
        d.Flashing := FlashingState;
        if d.Counter=0 then d.Flashing := false;
        if d.Flashing then TMiControl(d.Control).Visible := not TMiControl(d.Control).Visible
                      else TMiControl(d.Control).Visible := d.OrigVisible;
      except
        d.Counter := 0;
      end;
  end;
end;

function IndexOfFlashControl( AControl: TControl ): integer;
begin
  for result := 0 to FlashList.Count-1 do
    if TFlashData(FlashList[result]).Control=AControl then exit;
  result := -1;
end;

procedure FlashControl( Control: TControl; Style: TFlashStyle; Color: TColor; time: word );
var
  i : integer;
  d : TFlashData;
begin
  if Control=nil then exit;
  if FlashList=nil then FlashList := TObjectList.Create;
  for i := 0 to FlashList.Count-1 do
  begin
    d := TFlashData(FlashList[i]);
    if d.Control=Control then
    begin
      d.Counter := time;
      if d.Counter=0 then
      begin
        FlashTickControl(d);
        FlashList.Delete(i);
      end;
      exit;
    end;
  end;
  if time=0 then exit;
  d := TFlashData.Create(nil);
  d.Style      := Style;
  d.Control    := Control;
  if Control is TForm then d.FormHandle := (Control as TForm).Handle
                      else d.FormHandle := 0;
  d.Control.FreeNotification(d);
  d.Color      := Color;
  d.Counter    := time;
  case Style of
    fsBackground: d.OrigColor   := TMiControl(Control).Color;
    fsFont:       d.OrigColor   := TMiControl(Control).Font.Color;
    fsVisible:    d.OrigVisible := TMiControl(Control).Visible;
  else            d.OrigColor   := 0;
  end;
  d.Flashing   := false;
  FlashList.Add(d);
end;

procedure FlashForm( Form: TForm; time: word );
begin
  FlashControl(Form,fsCaption,0,time);
end;

procedure FlashStop( Control: TControl );
var
  i : integer;
  d : TFlashData;
begin
  i := IndexOfFlashControl(Control);
  if i<0 then exit;
  d := TFlashData(FlashList[i]);
  d.Counter := 0;
  FlashTickControl(d);
  FlashList.Delete(i);
end;

procedure FlashTick;
var
  i : integer;
  d : TFlashData;
begin
  if (FlashList=nil) or (FlashList.Count=0) then exit;
  FlashingState := not FlashingState;
  i := 0;
  while i<FlashList.Count do
  begin
    d := TFlashData(FlashList[i]);
    FlashTickControl(d);
    if d.Counter>0 then inc(i)
    else
    begin
      FlashList.Delete(i);
    end;
  end;
end;

{Sonidos}

type
  TMiMediaPlayer = class(TMediaPlayer)
  private
    procedure MediaPlayerNotify(Sender: TObject);
  public
    NoInterrumpirSonido : boolean;
    constructor Create( AOwner: TComponent ); override;
  end;

var
  MediaPlayer : TMiMediaPlayer = nil;

procedure TMiMediaPlayer.MediaPlayerNotify(Sender: TObject);
begin
  if NotifyValue=nvSuccessful then
  begin
    Close;
    NoInterrumpirSonido := false;
  end;
end;

constructor TMiMediaPlayer.Create( AOwner: TComponent );
begin
  inherited Create(AOwner);
  OnNotify := MediaPlayerNotify;
end;

{procedure PlaySound( const nomarch: string; interrumpir: boolean );
begin
  if nomarch='' then exit;
  if MediaPlayer=nil then
  begin
    MediaPlayer := TMiMediaPlayer.Create(nil);
    MediaPlayer.Parent := Application.MainForm;
    if MediaPlayer.Parent=nil then MediaPlayer.ParentWindow := Application.Handle;
    MediaPlayer.Visible := false;
    MediaPlayer.DeviceType := dtWaveAudio;
  end;
  if MediaPlayer.NoInterrumpirSonido or (not interrumpir and (MediaPlayer.Mode=mpPlaying)) then exit;
  try
    MediaPlayer.Notify := false;
    if MediaPlayer.Mode=mpPlaying then MediaPlayer.Stop;
    MediaPlayer.Close;
    MediaPlayer.FileName := nomarch;
    MediaPlayer.Open;
    if MediaPlayer.Error<>0 then exit;
    MediaPlayer.Notify := true;
    MediaPlayer.NoInterrumpirSonido := interrumpir;
    MediaPlayer.Play;
  except
    MediaPlayer.NoInterrumpirSonido := false;
    MessageBeep($FFFF);
  end;
end;}

procedure PlaySound( const nomarch: string; interrumpir: boolean );
var
  f : dword;
begin
  if not SoundEnabled or (nomarch='') then exit;
  if interrumpir then f := 0 else f := SND_NOSTOP;
  if not MMSystem.PlaySound(PChar(nomarch),0,SND_FILENAME+SND_ASYNC+SND_NODEFAULT+f) and interrumpir then
    MessageBeep($FFFF);
end;

{ShowHintHandler}

type
  TShowHintData = record
    Control    : TControl;
    OnShowHint : TShowHintEvent;
  end;
  PShowHintData = ^TShowHintData;
  TShowHintManager = class
    SaveOnShowHint  : TShowHintEvent;
    Handlers        : TList;
    CacheSHLControl : TControl;
    CacheSHLFind    : PShowHintData;
    constructor Create;
    destructor Destroy; override;
    procedure AppShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
    function FindHandler( Control: TControl ): PShowHintData;
    function AddHandler( Control: TControl; Handler: TShowHintEvent ): integer;
    procedure RemoveHandler( Control: TControl );
  end;

var
  ShowHintManager : TShowHintManager = nil;

constructor TShowHintManager.Create;
begin
  inherited;
  Handlers := TList.Create;
  SaveOnShowHint := Application.OnShowHint;
  Application.OnShowHint := AppShowHint;
end;

destructor TShowHintManager.Destroy;
var
  i : integer;
begin
  for i := 0 to Handlers.Count-1 do
    Dispose(PShowHintData(Handlers[i]));
  Handlers.Free;
  Application.OnShowHint := SaveOnShowHint;
  inherited;
end;

function TShowHintManager.FindHandler( Control: TControl ): PShowHintData;
var
  i : integer;
begin
  if CacheSHLControl<>Control then
  begin
    for i := 0 to Handlers.Count-1 do
      if PShowHintData(Handlers[i])^.Control=Control then
      begin
        CacheSHLFind := PShowHintData(Handlers[i]);
        CacheSHLControl := Control;
        result := CacheSHLFind;
        exit;
      end;
    result := nil;
  end
  else result := CacheSHLFind;
end;

procedure TShowHintManager.AppShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
var
  h : PShowHintData;
begin
  h := FindHandler(HintInfo.HintControl);
  if h<>nil then h^.OnShowHint(HintStr,CanShow,HintInfo)
  else if assigned(SaveOnShowHint) then SaveOnShowHint(HintStr,CanShow,HintInfo)
end;

function TShowHintManager.AddHandler( Control: TControl; Handler: TShowHintEvent ): integer;
var
  d : PShowHintData;
begin
  d := ShowHintManager.FindHandler(Control);
  if d=nil then
  begin
    new(d);
    d^.Control := Control;
    Handlers.Add(d);
  end;
  d^.OnShowHint := Handler;
  result := integer(d);
end;

procedure TShowHintManager.RemoveHandler( Control: TControl );
var
  d : PShowHintData;
begin
  d := FindHandler(Control);
  if d=nil then exit;
  Handlers.Remove(d);
  Dispose(d);
  if Control=CacheSHLControl then
  begin
    CacheSHLControl := nil;
    CacheSHLFind := nil;
  end;
end;

procedure InstallShowHintHandler( Control: TControl; Handler: TShowHintEvent );
begin
  if ShowHintManager=nil then ShowHintManager := TShowHintManager.Create;
  ShowHintManager.AddHandler(Control,Handler);
end;

procedure RemoveShowHintHandler( Control: TControl );
begin
  if ShowHintManager=nil then exit;
  ShowHintManager.RemoveHandler(Control);
  if ShowHintManager.Handlers.Count>0 then exit;
  FreeAndNil(ShowHintManager);
end;

procedure ExecuteDefaultMenuItem( Menu: TMenu );
var
  i : integer;
begin
  for i := 0 to Menu.Items.Count-1 do
    with Menu.Items[i] do
      if Visible and Enabled and Default then
      begin
        if Action<>nil then Action.Execute
                       else Click;
        exit;
      end;
end;

procedure RestoreForm( Form: TForm );
begin
  if Form=nil then exit;
  if Form.WindowState=wsMinimized then Form.WindowState := wsNormal;
  Form.BringToFront;
end;

function FindForm( c: TComponentClass ): TForm;
var
  i : integer;
begin
  for i := 0 to Screen.FormCount-1 do
    if Screen.Forms[i] is c then
    begin
      result := Screen.Forms[i];
      exit;
    end;
  result := nil;
end;

function FindForm( const FormName: string ): TForm;
var
  i : integer;
begin
  for i := 0 to Screen.FormCount-1 do
    if Screen.Forms[i].Name=FormName then
    begin
      result := Screen.Forms[i];
      exit;
    end;
  result := nil;
end;

procedure CopyMenuItems( DestItem, SourceItem: TMenuItem );
  procedure CopyMenuItemsInterna( DestItem, SourceItem: TMenuItem ); forward;
  procedure AssignMenuItem( d, s: TMenuItem );
  begin
    d.Action     := s.Action;
    d.Caption    := s.Caption;
    d.Visible    := s.Visible;
    d.Enabled    := s.Enabled;
    d.Checked    := s.Checked;
    d.Default    := s.Default;
    d.Bitmap     := s.Bitmap;
    d.ImageIndex := s.ImageIndex;
    d.GroupIndex := s.GroupIndex;
    d.RadioItem  := s.RadioItem;
    d.Hint       := s.Hint;
    d.OnClick    := s.OnClick;
    d.Tag        := s.Tag;
  end;
  function CreateMenuItemCopy( i: TMenuItem ): TMenuItem;
  begin
    result := TMenuItem.Create(DestItem.Owner);
    AssignMenuItem(result,i);
    CopyMenuItemsInterna(result,i);
  end;
  procedure CopyMenuItemsInterna( DestItem, SourceItem: TMenuItem );
  var
    i : integer;
  begin
    for i := 0 to SourceItem.Count-1 do
      DestItem.Add(CreateMenuItemCopy(SourceItem.Items[i]));
  end;
begin
  CopyMenuItemsInterna(DestItem,SourceItem);
end;

procedure AssignMenu( DestMenu, SourceMenu: TMenu );
begin
  {while DestMenu.Items.Count>0 do
    DestMenu.Items.Delete(0);}
  DestMenu.Items.Clear;
  CopyMenuItems(DestMenu.Items,SourceMenu.Items);
  DestMenu.Images := SourceMenu.Images;
end;

procedure EnableMenuItems( MenuItem: TMenuItem; Enabled: boolean; From: integer= 0; SubMenus: boolean= false );
var
  i : integer;
begin
  for i := From to MenuItem.Count-1 do
    if MenuItem.Items[i].Action=nil then
      if      MenuItem.Items[i].Count=0 then MenuItem.Items[i].Enabled := Enabled
      else if SubMenus                  then EnableMenuItems(MenuItem.Items[i],Enabled,0,true);
end;

type
  PTopMostEnumInfo = ^TTopMostEnumInfo;
  TTopMostEnumInfo = record
    TopWindow: HWND;
    IncludeMain: Boolean;
  end;
var
  FTopMostLevel : integer = 0;
  FTopMostList : TList = nil;

function GetTopMostWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
begin
  Result := True;
  {if GetWindow(Handle, GW_OWNER) = GetDesktopWindow then}
    if (GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0) then
      FTopMostList.Add(Pointer(Handle))
    else
    begin
      PTopMostEnumInfo(Info)^.TopWindow := Handle;
      Result := False;
    end;
end;

procedure NormalizeTopMosts;
var
  I: Integer;
  Info: TTopMostEnumInfo;
begin
  if Application.Handle <> 0 then
  begin
    if FTopMostLevel = 0 then
    begin
      if FTopMostList=nil then FTopMostList := TList.Create;
      Info.TopWindow := Application.Handle;
      Info.IncludeMain := true; // no usado
      EnumWindows(@GetTopMostWindows, Longint(@Info));
      if FTopMostList.Count <> 0 then
      begin
        Info.TopWindow := GetWindow(Info.TopWindow, GW_HWNDPREV);
        if GetWindowLong(Info.TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
          Info.TopWindow := HWND_NOTOPMOST;
        for I := FTopMostList.Count - 1 downto 0 do
          SetWindowPos(HWND(FTopMostList[I]), Info.TopWindow, 0, 0, 0, 0,
            SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
      end;
    end;
    Inc(FTopMostLevel);
  end;
end;

procedure RestoreTopMosts;
var
  I: Integer;
begin
  if (Application.Handle <> 0) and (FTopMostLevel > 0) then
  begin
    Dec(FTopMostLevel);
    if FTopMostLevel = 0 then
    begin
      for I := FTopMostList.Count - 1 downto 0 do
        SetWindowPos(HWND(FTopMostList[I]), HWND_TOPMOST, 0, 0, 0, 0,
          SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
      FTopMostList.Clear;
    end;
  end;
end;

function ComboBoxToObject( cb: TCustomComboBox; const default: pointer= nil ): pointer;
begin
  with cb do
    if ItemIndex>=0 then result := Items.Objects[ItemIndex]
                    else result := default;
end;

procedure ObjectToComboBox( cb: TCustomComboBox; obj: pointer; default: integer= -1 );
var
  i : integer;
begin
  with cb do
  begin
    i := Items.IndexOfObject(obj);
    if i>=0 then ItemIndex := i
            else ItemIndex := default
  end;
end;

function ComboBoxToStr( cb: TCustomComboBox; const default: string= '' ): string;
begin
  with cb do
    if ItemIndex>=0 then result := Items[ItemIndex]
                    else result := default;
end;

procedure StrToComboBox( cb: TCustomComboBox; const val: string; default: integer= -1 );
var
  i : integer;
begin
  with cb do
  begin
    i := Items.IndexOf(val);
    if i>=0 then ItemIndex := i
            else ItemIndex := default
  end;
end;

function ComboBoxToInteger( cb: TCustomComboBox; const default: integer= 0 ): integer;
begin
  with cb do
    if ItemIndex>=0 then result := integer(Items.Objects[ItemIndex])
                    else result := default;
end;

procedure IntegerToComboBox( cb: TCustomComboBox; val: integer; default: integer= -1 );
var
  i : integer;
begin
  with cb do
  begin
    i := Items.IndexOfObject(pointer(val));
    if i>=0 then ItemIndex := i
            else ItemIndex := default
  end;
end;

procedure SetListBoxScrollWidth(LB:TCustomListBox);
var i,k,max:Integer;
begin
  max := 0;
  with LB do
    for i := 0 to Count-1 do
    begin
      k := Canvas.TextWidth(Items[i]);
      if k>max then max := k;
    end;
  LB.ScrollWidth := max;
end;

procedure SetComboBoxDropWidth(CB:TCustomComboBox);
var i,k,max:Integer;
begin
  max := 0;
  with CB do
    for i := 0 to Items.Count-1 do
    begin
      k := Canvas.TextWidth(Items[i])+20;
      if k>max then max := k;
    end;
  SendMessage(CB.Handle,CB_SETDROPPEDWIDTH,max,0);
end;

procedure SetChildControlsEnabled( c: TWinControl; enbld: boolean );
var
  i : integer;
begin
  for i := 0 to c.ControlCount-1 do
    c.Controls[i].Enabled := enbld;
end;

procedure SetLayeredAttribs( Handle: HWND; FAlphaBlend, FTransparentColor: boolean; FAlphaBlendValue: integer; FTransparentColorValue: TColor );
const
  cUseAlpha: array [Boolean] of Integer = (0, LWA_ALPHA);
  cUseColorKey: array [Boolean] of Integer = (0, LWA_COLORKEY);
type
  TSetLayeredWindowAttributes = function (Hwnd: THandle; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;
var
  AStyle: Integer;
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
  procedure InitProcs;
  const
    sUser32 = 'User32.dll';
  var
    ModH: HMODULE;
  begin
    ModH := GetModuleHandle(sUser32);
    if ModH <> 0 then
      @SetLayeredWindowAttributes := GetProcAddress(ModH, 'SetLayeredWindowAttributes')
    else
      SetLayeredWindowAttributes := nil;
  end;
begin
  InitProcs;
  if (Assigned(SetLayeredWindowAttributes)) and (Handle<>0) then
  begin
    AStyle := GetWindowLong(Handle, GWL_EXSTYLE);
    if FAlphaBlend or FTransparentColor then
    begin
      if (AStyle and WS_EX_LAYERED) = 0 then
        SetWindowLong(Handle, GWL_EXSTYLE, AStyle or WS_EX_LAYERED);
      SetLayeredWindowAttributes(Handle, FTransparentColorValue, FAlphaBlendValue,
        cUseAlpha[FAlphaBlend] or cUseColorKey[FTransparentColor]);
    end
    else
    begin
      SetWindowLong(Handle, GWL_EXSTYLE, AStyle and not WS_EX_LAYERED);
      RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_FRAME or RDW_ALLCHILDREN);
    end;
  end;
end;

{ TShadowForm }

procedure TShadowForm.CMVisibleChanged(var Message: TMessage);
begin
  if Visible then
    DisplayShadow
  else
    HideShadow;
  inherited;
end;

procedure TShadowForm.WMWindowPosChanged(var Message: TWMWindowPosChanged);
begin
  if Visible then
  begin
    HideShadow;
    DisplayShadow;
  end;
  inherited;
end;

procedure TShadowForm.DisplayShadow;
begin
  if Shadow {and not DesignMode} and not FShadowVisible then
  begin
    if not Assigned(FRShadow) then
    begin
      FRShadow := TShadowWindow.CreateShadow(Self, csRight);
      FBShadow := TShadowWindow.CreateShadow(Self, csBottom);
    end;
    if Assigned(FRShadow) then
    begin
      FRShadow.Control := Self;
      FBShadow.Control := Self;
    end;
    FShadowVisible := true;
  end;
end;

procedure TShadowForm.HideShadow;
begin
  if not Assigned(FRShadow) or not Shadow or not FShadowVisible then exit;
  FRShadow.Hide;
  FBShadow.Hide;
  FShadowVisible := false;
end;

procedure TShadowForm.SetShadow(const Value: boolean);
begin
  if FShadow=Value then exit;
  FShadow := Value;
  RecreateWnd;
end;

end.
